Утилиты

Может быть вы встречали ситуацию, когда в Windows существуют приложения, которые не видны и на которые нельзя переключиться ни с помощью Alt+Tab, ни с помощью Task Manger.

Аналог Pascal процедуры Delay в Delphi.

Как узнать и поменять разрешение экрана?

Здесь Вы можете посмотреть предложение из FIDO.RU о замене разрешения экрана:

procedure ChangeDisplayResolution(X, Y : Word);

var

Dm : TDEVMODE;

begin

ZeroMemory(@Dm, SizeOf(TDEVMODE));

Dm.DmSize := SizeOf(TDEVMODE);

Dm.DmPelsWidth := X;

Dm.DmPelsHeight := Y;

Dm.DmFields := DM_PELSWIDTH or DM_PELSHEIGHT;

ChangeDisplaySettings(Dm, 0);

end;

Как по Click на TLabel послать электронную почту?

Ivanuts V. 7 апреля 1999 г
ivanuts@altavista.net

Иногда бывает необходимо предоставить возможность пользователю отослать электронное письмо или запустить Интернет-Браузер по "клику" на определенном "контроле" информации. Такое действие реализуется следующим образом (к примеру в DBGrid):

uses ShellApi, ......;

......

procedure TForm1.DBGrid2DblClick(Sender: TObject);

begin

if (Table1.RecordCount > 0) and (Trim(Table1.FieldByName('EMAIL').asString) > '') then

ShellExecute(Handle, 'open', 'mailto:' + Table1.FieldByName('EMAIL').asString, '', '', SW_SHOWNORMAL);

end;

......

Здесь приведен пример запуска средств электронной почты. Если необходимо запустить Интернет-Браузер, используйте вместо выражения mailto: выражение http:\\ (если эти выражения не присутствуют у Вас в строковом поле).

Более подробно о функции ShellExecute и ее производных читайте в Help for Windows ShellApi.

Как зашифровать и разшифровать пароль пользователя?

Yri Beskorovayniy 12 февраля 1999 г
Yra@amd.kaluga.ru

Была у меня тоже такая проблема. Все решения что я видел (на Torry тоже смотрел) обладали недостатками:
1) Работали с блоками информации и выходные данные превышали размер входных. Если не превышали то были очень легкими для вскрытия.
2) Выходные данные содержали символы #0, что при шифровании текстовых данных очень нежелательно.
3) Были просто огромны по своим размерам.
4) Цифровые ключи имели огромные размеры.

По этому пришлось сделать свои процедурки. Постарался учесть печальный опыт предыдущих процедур, пробегавших в эхе, и вышеуказанных замечаний.

Что они могут а чего не могут:
1) Входная текстовая информация должна находится в пределах 32-127 (анлийский текст цифры и символы, табуляторы и символы переводы строки), 192-255 (русские буквы в Win 1251). Если входной текст выходит за эти пределы, результат станет неизвестен.
2) Hа выходе получаете КОРРЕКТHЫЙ (т.е. нет символов со значеним #0) текст и такой же длинны, диапазона 32-255.
3) Для криптования текстовых файлов (расширение диапазона до 9-127 и 192-255) необходимо заменить константу Diap на 7, и читать файл потоком или единым блоком но не ReadLn (так как может встретится $D $A). При этом диапазон расширяется до 9-255.
4) Тектовой пароль (максимум 8 символов).
5) Применено 3 алгоритма криптования:

1) Сложение по XOR нижних 5 бит с паролем.

2) Замена по Random символа.

3) Перемешивание символов в выходных данных по Random (чем длинне строка тем эффективнее, 1 - 3 символа вообще не имеет смысла).

Все это уместилось в 55 строк (см. ниже). По моим подсчетам (если не прав, поправте) вариантов для перебора 3,883798553361e+17, т.е. 2^5764801, что вполне приемлемо для бытовых-деловых применений (естественно до PGP далеко :-))) но от злобного юзера пароль скроет на века :-)))).

Вот собственно процедурки:

function Crypt(const StrIn : String; const Password : String) : String;

const

Diap = 31; // Для текстовых файлов 7

var

I, J, Key1, Key2 : Integer; // Паролей - 3,883798553361e+17, т.е. 2^5764801

Buff : String;

Pass : String[8];

begin

Pass := Password;

Key1 := 0;

for I := 1 to Length(Pass) do

Key1 := (Key1 xor Ord(Pass[I])) * Ord(Pass[I]);

Key2 := Key1 xor (Ord(Pass[1]) * Key1);

RandSeed := Key1;

Result := '';

Buff := '';

for I := 1 to Length(StrIn) do

if Ord(StrIn[I]) <= 160 then

Buff := Buff + Chr((Ord(StrIn[I]) xor (Key1 and Diap)) + Random(32))

else

Buff := Buff + Chr((Ord(StrIn[I]) xor (Key1 and Diap)) - Random(32));

RandSeed := Key2; //Тусуем буковки :-)))

for I := 1 to Length(StrIn) do

begin

J := Random(Length(Buff) - 1) + 1;

Result := Result + Copy(Buff, J, 1);

Buff := Copy(Buff, 1, J - 1) + Copy(Buff, J + 1, Length(Buff));

end;

function UnCrypt(const StrIn : String; const Password : String) : String;

const Diap = 31; // Для текстовых файлов 7

var

I, J, Key1, Key2 : Integer;

Buff, Por : String;

Pass : String[8];

begin

Pass := Password;

Key1 := 0;

for I := 1 to Length(Pass) do

Key1 := (Key1 xor Ord(Pass[I])) * Ord(Pass[I]);

Key2 := Key1 xor (Ord(Pass[I]) * Key1);

RandSeed := Key2;

Result := '';

Por := '';

Buff := StrIn;

for I := 1 to Length(StrIn) do //Тусуем буковки обратно :-)))

begin

J := Random(Length(Buff) - 1) + 1;

Insert(Chr(J), Por, 1);

Result := Result + Copy(Buff, Length(Buff), 1);

Delete(Buff, Length(Buff), 1);

end;

Buff := '';

for I := 1 to Length(StrIn) do

Insert(Copy(Result, I, 1), Buff, Ord(Por[I]));

Result := '';

RandSeed := Key1;

for I := 1 to Length(StrIn) do

if Ord(Buff[I]) <= 160 then

Result := Result + Chr((Ord(Buff[I]) - Random(32)) xor (Key1 and Diap))

else

Result := Result + Chr((Ord(Buff[I]) + Random(32)) xor (Key1 and Diap));

end;

Как хpанить OLE-объекты в BLOB-полях таблиц?

Igor Tikhorenko 12 февраля 1999 г
Igor.Tikhorenko@p19.f4.n5019.z2.fidonet.org

Вот пpимеp из книги Т.Миллеpа:

procedure TfrmMain.LoadFromStreamOLE;

var

BS : TBlobStream;

begin

BS := TBlobStream.Create(Table1.FieldByName('OLE_Object') as TBlobField, bmRead);

if BS.Size <> 0 then

try

with frmOLE, OLEContainer1 do

begin

LoadFromStream(BS);

AllowInPlace := True;

end; // with

finally

BS.Free;

end; // Try

end;

procedure TfrmMain.WriteToStreamOLE;

var

BS : TBlobStream;

begin

BS := TBlobStream.Create(Table1.FieldByName('OLE_Object') as TBlobField, bmWrite);

try

with frmOLE.OLEContainer1 do

if State <> osEmpty then

SaveToStream(BS);

finally

BS.Free;

end; { try }

end;

Как по IP адресу получить HostName (и обратно)?

Alex Konshin (alexk@msmt.spb.su) 7.2.1999

Такую задачу выполняет функция GetHostByAddr, а при Winsock2, можно использовать WSAAddressToString.

Вот небольшой пример, в котоpом эти функции используются (не пpетендую на абсолютную истину, но с IP pаботает):

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;

const

AddressStrMaxLen = 256;

var

Len : DWORD;

Ptr : PChar;

pHE : PHostEnt;

Addr : TSockAddr;

Buf : array[0..AddressStrMaxLen - 1] of Char;

begin

if FNet = nil then

raise ESocketError.Error(-1, ClassName + '.GetPeerAds: Net is not defined', WSAHOST_NOT_FOUND);

Len := SizeOf(TSockAddr);

if GetPeerName(FSocket, Addr, Len) <> 0 then

RaiseLastSocketError(-1, ClassName + '.GetPeerAds: GetPeerName()');

case Addr.Sin_Family of

AF_INET: // TCP/IP

begin

pHE := GetHostByAddr(PChar(@Addr.Sin_Addr), SizeOf(TInAddr), AF_INET);

if pHE = nil then

RaiseLastSocketError(-1, ClassName + '.GetPeerAds: GetHostByAddr()');

FPeerNodeName := pHE^.H_Name;

if FNet.NodeByName(FPeerNodeName) = nil then

begin

Ptr := StrScan(pHE^.H_Name, '.');

if Ptr <> nil then

FPeerNodeName := Copy(pHE^.H_Name, 1, Ptr - pHE^.H_Name);

end;

else

Len := AddressStrMaxLen;

if WSAAddressToStringA(Sin, SinLen, nil, Buf, Len) <> 0 then

RaiseLastSocketError(-1, ClassName + '.GetPeerAds: WSAAddressToStringA()');

Ptr := StrRScan(Buf, ':');

if Ptr <> nil then Len := Ptr - Buf;

FPeerNodeName := Copy(Buf, 1, Len);

end;

Result := FNet.EncodeAddress(ALogin, FPeerNodeName, '', [bLoginIdRequired, bNodeIdREquired, bRaiseError]);

end; {TGenericNetTask.GetPeerOrigin}

Как создавать ярлыки на рабочем столе?

Roman Ryltsov (ryltsov@geocities.com) 7.2.1999

function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string): IPersistFile;

var

MyObject : IUnknown;

MySLink : IShellLink;

MyPFile : IPersistFile;

WideFile : WideString;

begin

MyObject := CreateComObject(CLSID_ShellLink);

MySLink := MyObject as IShellLink;

MyPFile := MyObject as IPersistFile;

with MySLink do

begin

SetPath(PChar(CmdLine));

SetArguments(PChar(Args));

SetWorkingDirectory(PChar(WorkDir));

end;

WideFile := LinkFile;

MyPFile.Save(PWChar(WideFile), False);

Result := MyPFile;

end;

procedure CreateShortcuts;

var

Directory, ExecDir : String;

MyReg : TRegIniFile;

begin

MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');

ExecDir := ExtractFilePath(ParamStr(0));

Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' + ProgramMenu;

CreateDir(Directory);

MyReg.Free;

CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir, Directory + '\Demonstration.lnk');

CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir, Directory + '\Installation notes.lnk');

CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir, Directory + '\Install Intel Video Interactive.lnk');

end;

Akzhan Abdulin

Гм. Вообще правильнее в процедуре CreateShortcuts пользовать Win32API::GetSpecialFolderLocation с нужным параметром (CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола").

Как программно включить/отключить PC Speaker?

Alexey Lesovik 7.2.1999

Это выключит спикеp:

SyStemParametersInfo(SPI_SETBEEP, 0, nil, SPIF_UPDATEINIFILE);

Это включит:

SyStemParametersInfo(SPI_SETBEEP, 1, nil, SPIF_UPDATEINIFILE);

Как инсталлировать на время работы программы свои шрифты?

Дайджест по конференции RU.DELPHI (составил Nick Slepchenko) 29.1.1999

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно следующим образом:

  ........................................................
  {$IFDEF WIN32}
  AddFontResource( PChar( My_Font_PathName { AnsiString } ) );
  {$ELSE}
  var
    SS  : array [ 0..255 ] of Char;

  AddFontResource ( StrPCopy ( SS, My_Font_PathName ));
  {$ENDIF}
  SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
  ........................................................

Убрать его по окончании работы:

  ........................................................
  {$IFDEF WIN32}
  RemoveFontResource ( PChar(My_Font_PathName) );
  {$ELSE}
  RemoveFontResource ( StrPCopy ( SS, My_Font_PathName ));
  {$ENDIF}
  SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
  ........................................................

Где My_Font_PathName - полный путь к файлу со шрифтом.

Как из программы управлять иконками рабочего стола?

Borland FAQ N687 (переведен Акжаном Абдулиным) 4.1.1999

Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять Handle этого органа управления. Пример:

 
function GetDesktopListViewHandle : THandle;
var
  S : String;
begin
  Result := FindWindow('ProgMan', nil);
  Result := GetWindow(Result, GW_CHILD);
  Result := GetWindow(Result, GW_CHILD);
  SetLength(S, 40);
  GetClassName(Result, PChar(S), 39);
  if PChar(S) <> 'SysListView32' then Result := 0;
end;

После того, как Вы взяли этот Handle, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:

SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );

разместит иконки рабочего стола по левой стороне рабочего стола Windows.

Как из программы переключать языки?

Anton Geleznyak, Valentin Lavrinenko 4.1.1999

Здесь переключатели на русский и на английский языки:

procedure SetRU;
var
  Layout : array[0.. KL_NAMELENGTH] of Char;
begin
  LoadKeyboardLayout(StrCopy(Layout, '00000419'), KLF_ACTIVATE);
end;

procedure SetEN;
var
  Layout : array[0.. KL_NAMELENGTH] of Char;
begin
  LoadKeyboardLayout(StrCopy(Layout, '00000409'), KLF_ACTIVATE);
end;

Можно и так:

var 
  Rus, Lat : HKL;
. . .
  Rus := LoadKeyboardLayout('00000419', 0);
  Lat := LoadKeyboardLayout('00000409', 0);
  SetActiveKeyboardLayout(Rus);
. . .

Как получить список установленных модемов в Win95/98?

Stas Malinovski 3.1.1999

Предлагаю следующий модуль для этих целей:

unit PortInfo;

interface

uses
  Windows, SysUtils, Classes, Registry;

function EnumModems : TStrings;

implementation

function EnumModems : TStrings;
var
  R : TRegistry;
  S : ShortString;
  N : TStringList;
  I : Integer;
  J : Integer;
begin
  Result := TStringList.Create;
  R := TRegistry.Create;
  try
    with R do 
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) 
      then
        if HasSubKeys then 
        begin
          N := TStringList.Create;
          try
            GetKeyNames(N);
            for I := 0 to N.Count - 1 do 
            begin
              OpenKey(N[I], False);
              S := ReadString('AttachedTo');
              for J := 1 to 4 do
                if Pos(Chr(J + Ord('0')), S) > 0 then Break;
              Result.AddObject(ReadString('DriverDesc'), TObject(J));
              CloseKey;
            end;
          finally
            N.Free;
          end;
        end;
    end;
  finally
    R.Free;
  end;
end;

end.

Как программно изменить количество копий выводимых в печать?

Ivanuts V.A. (ivanuts@altavista.net) 2.1.1999

Если эта задача стоит в процессе вывода на печать документов из QuickReport, то достаточно изменить значение свойства PrinterSettings.Copies, например:

procedure TMyForm.PrintBtnClick(Sender : TObject);
begin

QuickReport1.PrinterSettings.Copies := StrToInt(Edit1.Text);
end;

Если же печать документа производится путем функциональных возможностей модуля Printers, то необходимо организовать цикл повторения печати, например:

procedure TMyForm.PrintBtnClick(Sender : TObject);

var

I : Integer;

begin

for I := 0 to StrToInt(Edit1.Text) do

begin

Printer.BeginDoc;

. . .

Printer.EndDoc;

end;

Как проверить диск на наличие *.dbf в директории программы и соответствия полей?

Ivanuts V.A. (ivanuts@altavista.net ) 20.12.1998
1. Для определения наличия любого файла на диске используется стандартное выражение:

if not FileExists(FTableName) then

raise EError.Create('Таблица ' + ExtractFileName(FTableName) + ' по указанному пути отсутствует.')

2. Чтобы перед использованием DBF-таблицы проверить ее версию можно воспользоваться следующей функцией:

const

DB3 = $03; //Версия 3.х

DB4 = $04; //Версия 4.х

DB5 = $05; //Версия for Windows

DB3Memo = $83; //Версия 3.х cполями MEMO

DB4Memo = $84; //Версия 4.х cполями MEMO

function TMyMenu.GetTableVersion : Byte;

....

FFile := TFileStream.Create (FTableName, fmOpenReadWrite);

try

//Информация о заголовке таблицы

FFile.Seek(0, soFrombeginning);

FFile.ReadBuffer(FHeader, Sizeof(FHeader)); //FHeader - переменная, указывающая на структуру заголовка

Result := FHeader.VersionNumber; //Здесь VersionNumber - поле из записи FHeader

except

Raise EError.Create('Ошибка чтения заголовка таблицы.');

end;

....

Дальше зная с какой именно таблицей приходится работать, нетрудно выбрать переменую, указывающую на структуру полей таблицы и т.д.

Как получить название ОС и номер ее версии? ("Windows 95" или "Windows NT"...)

Ivanuts V.A. (ivanuts@altavista.net ) 5.12.1998
Правилом хорошего тона в программировании для Windows, является организация данных о программном продукте в системном реестре. Согласно этому правилу и сама операционная система Windows (как 95-98 так и NT) содержат в реестре информацию о себе. Прочесть информацию о версии можно следующей функцией:

type

TInformation = record

PrName,

PrDirectory,

PrVersion : String;

end;

const

RootKey = HKEY_LOCAL_MACHINE;

CurrentVersion = '\SOFTWARE\Microsoft\Windows\CurrentVersion';

ProductName = 'ProductName';

RootDirectory = 'SystemRoot';

Version = 'VersionNumber';

function GetInformation : TInformation;

var

Reg : TRegistry;

begin

Reg := TRegistry.Create;

try

Reg.RootKey := RootKey;

Reg.OpenKey(CurrentVersion, False);

Result.PrDirectory := Reg.ReadString(RootDirectory);

Result.PrName := Reg.ReadString(ProductName);

Result.PrVersion := Reg.ReadString(Version);

finally

Reg.Free;

end;

Как вывести на принтер текст поверх картинки.

Ivanuts V.A. (ivanuts@altavista.net ) 1.12.1998
Я бы эту задачу выполнил примерно так:

K := 20;

with Printer.Canvas do

begin

StretchDraw(20, 20, 600, 900, MyImage.Picture.Graphic);

for I := 0 toMemo1.Lines.Items.Count - 1 do

begin

TextOut(20, K, Memo1.Lines.Items[I]);

K := K + 20;

end;

Каким образом или какой функцией установить системную дату и время Windows 95 средствами Delphi.

Ivanuts V.A. (ivanuts@altavista.net ) 1.12.1998
В своих приложениях, которые требуют установки единого времени и даты на разных машинах, я использую установку системного времени и даты , взятых путем запроса с сервера БД. У меня это работает вот так:

procedure TGlavMenu.SetSysTime(Sender: TObject);

var

Present : TSystemTime;

Year, Month, Day, Hour, Min, Sec, MSec: Word;

begin

qrTime.Open;{ Этот квери возвращает системное время и дату с сервера БД. Здесь можно использовать и другие источники - например TEdit и т.д.}

DecodeDate(qrTimeDATE.Value, Year, Month, Day);

DecodeTime(qrTimeDATE.Value, Hour, Min, Sec, MSec);

Present.wYear := Year;

Present.wMonth := Month;

Yares := Year;

Months := Month;

Present.wDay := Day;

Present.wHour := Hour - 3;

Present.wMinute := Min;

Present.wSecond := Sec;

Present.wMilliseconds := MSec;

SetSystemTime(Present);

qrTime.Close;

end;

Ivanuts V.A. (ivanuts@altavista.net ) 1.12.1998
Если речь идет о выполнении файла в паралельном процессе, то необходимо создать такой процесс:

var

Startup: TStartupInfo;

Process: TProcessInformation;

Status: DWORD;

szApp, szCmdLine : String;

Env: Pointer;

begin

Result := UM_ERROR;

Startup.lpReserved := PChar(0);

Startup.lpDesktop := PChar(0);

Startup.lpTitle := PChar(0);

Startup.dwFlags := STARTF_USESHOWWINDOW;

Startup.wShowWindow := SW_HIDE;{Вот здесь и необходимо выбрать способ запуска - видимое или скрытое окно.}

Startup.cbReserved2 := 0;

Startup.lpReserved2 := PByte(0);

if CreateProcess(

PChar(szApp), // lpApplicationName

PChar(szCmdLine), // lpCommandLine

PSecurityAttributes(0), // lpProcessAttributes

PSecurityAttributes(0), // lpThreadAttributes

False, // bInheritHandles

HIGH_PRIORITY_CLASS, // dwCreationFlags

Env, // lpEnvironment

PChar(0), // lpCurrentDirectory

Startup, // lpStartupInfo

Process // lpProcessInformation) then

begin

GetExitCodeProcess(Process.hProcess, Status);

while Status = STILL_ACTIVE do

begin

Sleep(10);

GetExitCodeProcess(Process.hProcess, Status);

end;

Result := Status;

end;

Результат такой функции и даст ответ о завершении процесса. Подробней о функциях CreateProcess и GetExitCodeProcessможно прочесть в Help for Delphi.

Копирование нескольких файлов.

Вставьте файл FMXUTILS.PAS из каталога x:\delphi\demos\doc\filmanex в ваш проект. Этот модуль содержит процедуру копирования файла. Однако там есть маленькая ошибка - не копируется время и дата создания файла. Эту ошибку легко исправить. Нужно использовать процедуру FileSetDate и функцию FileGetDate (для получения даты и времени исходного файла).

А эта функция позволяет скопиpовать как весь файл пpи From и Count = 0, так и пpоизвольный его кусок.

  ........................................................
  function CopyFile(InFile, OutFile : String; 
                           From, Count : Longint ) : Longint;
  var
    InFS, OutFS : TFileStream;
  begin
    InFS  := TFileStream.Create( InFile,  fmOpenRead );
    OutFS := TFileStream.Create( OutFile, fmCreate );
    InFS.Seek( From, soFromBeginning );
    Result := OutFS.CopyFrom( InFS, Count );
    InFS.Free;
    OutFS.Free;
  end;
  ........................................................

Организовать такое приложение можно с помощью вызова API, функция ShowWindow(), например:

procedure TForm1.OnPaint(Sender:TObject);

begin

ShowWindow(Form1.Handle, SW_HIDE);

end;

Аналог Pascal процедуры Delay в Delphi.

procedure TForm1.Delay(msecs : Longint);

var

FirstTick : Longint;

begin

FirstTick := GetTickCount;

repeat

Application.ProcessMessages;

{для того чтобы не "завесить" Windows}

until GetTickCount - FirstTick >= msecs;

end;

Оглавление
Назад